home *** CD-ROM | disk | FTP | other *** search
/ PD Collection CD 1 / PD Collection CD 1.iso / programer2 / lisp / xlisp / !XLisp / c / XLPRIN < prev    next >
Text File  |  1990-02-23  |  3KB  |  183 lines
  1. /* xlprint - xlisp print routine */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. #ifdef MEGAMAX
  9. overlay "io"
  10. #endif
  11.  
  12. /* external variables */
  13. extern char buf[];
  14.  
  15. /* xlprint - print an xlisp value */
  16. void xlprint(fptr,vptr,flag)
  17.   NODE *fptr,*vptr; int flag;
  18. {
  19.     NODE *nptr;
  20.     NODE *next = NIL;
  21.     int n,i;
  22.  
  23.     /* print nil */
  24.     if (vptr == NIL) {
  25.     xlputstr(fptr,"NIL");
  26.     return;
  27.     }
  28.  
  29.     /* check value type */
  30.     switch (ntype(vptr)) {
  31.     case SUBR:
  32.         putatm(fptr,"Subr",vptr);
  33.         break;
  34.     case FSUBR:
  35.         putatm(fptr,"FSubr",vptr);
  36.         break;
  37.     case LIST:
  38.         xlputc(fptr,'(');
  39.         for (nptr = vptr; nptr != NIL; nptr = next) {
  40.             xlprint(fptr,car(nptr),flag);
  41.         if (next = cdr(nptr))
  42.             if (consp(next))
  43.             xlputc(fptr,' ');
  44.             else {
  45.             xlputstr(fptr," . ");
  46.             xlprint(fptr,next,flag);
  47.             break;
  48.             }
  49.         }
  50.         xlputc(fptr,')');
  51.         break;
  52.     case SYM:
  53.         xlputstr(fptr,getstring(getpname(vptr)));
  54.         break;
  55.     case INT:
  56.         putdec(fptr,getfixnum(vptr));
  57.         break;
  58.     case FLOAT:
  59.         putfloat(fptr,getflonum(vptr));
  60.         break;
  61.     case STR:
  62.         if (flag)
  63.         putstring(fptr,getstring(vptr));
  64.         else
  65.         xlputstr(fptr,getstring(vptr));
  66.         break;
  67.     case FPTR:
  68.         putatm(fptr,"File",vptr);
  69.         break;
  70.     case OBJ:
  71.         putatm(fptr,"Object",vptr);
  72.         break;
  73.     case VECT:
  74.         xlputc(fptr,'#'); xlputc(fptr,'(');
  75.         for (i = 0, n = getsize(vptr); n-- > 0; ) {
  76.         xlprint(fptr,getelement(vptr,i++),flag);
  77.         if (n) xlputc(fptr,' ');
  78.         }
  79.         xlputc(fptr,')');
  80.         break;
  81.     case FREE:
  82.         putatm(fptr,"Free",vptr);
  83.         break;
  84.     default:
  85.         putatm(fptr,"Foo",vptr);
  86.         break;
  87.     }
  88. }
  89.  
  90. /* xlterpri - terminate the current print line */
  91. xlterpri(fptr)
  92.   NODE *fptr;
  93. {
  94.     xlputc(fptr,'\n');
  95. }
  96.  
  97. /* xlputstr - output a string */
  98. xlputstr(fptr,str)
  99.   NODE *fptr; char *str;
  100. {
  101.     while (*str)
  102.     xlputc(fptr,*str++);
  103. }
  104.  
  105. /* putstring - output a string */
  106. LOCAL putstring(fptr,str)
  107.   NODE *fptr; char *str;
  108. {
  109.     int ch;
  110.  
  111.     /* output the initial quote */
  112.     xlputc(fptr,'"');
  113.  
  114.     /* output each character in the string */
  115.     while (ch = *str++)
  116.  
  117.     /* check for a control character */
  118.     if (ch < 040 || ch == '\\') {
  119.         xlputc(fptr,'\\');
  120.         switch (ch) {
  121.         case '\033':
  122.             xlputc(fptr,'e');
  123.             break;
  124.         case '\n':
  125.             xlputc(fptr,'n');
  126.             break;
  127.         case '\r':
  128.             xlputc(fptr,'r');
  129.             break;
  130.         case '\t':
  131.             xlputc(fptr,'t');
  132.             break;
  133.         case '\\':
  134.             xlputc(fptr,'\\');
  135.             break;
  136.         default:
  137.             putoct(fptr,ch);
  138.             break;
  139.         }
  140.     }
  141.  
  142.     /* output a normal character */
  143.     else
  144.         xlputc(fptr,ch);
  145.  
  146.     /* output the terminating quote */
  147.     xlputc(fptr,'"');
  148. }
  149.  
  150. /* putatm - output an atom */
  151. LOCAL putatm(fptr,tag,val)
  152.   NODE *fptr; char *tag; NODE *val;
  153. {
  154.     sprintf(buf,"#<%s: #",tag); xlputstr(fptr,buf);
  155.     sprintf(buf,AFMT,val); xlputstr(fptr,buf);
  156.     xlputc(fptr,'>');
  157. }
  158.  
  159. /* putdec - output a decimal number */
  160. LOCAL putdec(fptr,n)
  161.   NODE *fptr; FIXNUM n;
  162. {
  163.     sprintf(buf,IFMT,n);
  164.     xlputstr(fptr,buf);
  165. }
  166.  
  167. /* putfloat - output a floating point number */
  168. LOCAL putfloat(fptr,n)
  169.   NODE *fptr; FLONUM n;
  170. {
  171.     sprintf(buf,"%g",n);
  172.     xlputstr(fptr,buf);
  173. }
  174.  
  175. /* putoct - output an octal byte value */
  176. LOCAL putoct(fptr,n)
  177.   NODE *fptr; int n;
  178. {
  179.     sprintf(buf,"%03o",n);
  180.     xlputstr(fptr,buf);
  181. }
  182.  
  183.